home *** CD-ROM | disk | FTP | other *** search
/ Night Owl 6 / Night Owl's Shareware - PDSI-006 - Night Owl Corp (1990).iso / 037a / svgabgi3.zip / VGADEMO.PAS < prev   
Pascal/Delphi Source File  |  1991-08-25  |  44KB  |  1,608 lines
  1. program BGIDemo;
  2. {
  3.  
  4.   Turbo Pascal Borland Graphics Interface (BGI) demonstration
  5.   program. This program shows how to use many features of
  6.   the Graph unit.
  7.  
  8.   Copyright (c) 1985-89 by Borland International, Inc.
  9.  
  10. }
  11.  
  12. uses
  13.   Crt, Dos, Graph;
  14.  
  15.  
  16. const
  17.   { The five fonts available }
  18.   Fonts : array[0..4] of string[13] =
  19.   ('DefaultFont', 'TriplexFont', 'SmallFont', 'SansSerifFont', 'GothicFont');
  20.  
  21.   { The five predefined line styles supported }
  22.   LineStyles : array[0..4] of string[9] =
  23.   ('SolidLn', 'DottedLn', 'CenterLn', 'DashedLn', 'UserBitLn');
  24.  
  25.   { The twelve predefined fill styles supported }
  26.   FillStyles : array[0..11] of string[14] =
  27.   ('EmptyFill', 'SolidFill', 'LineFill', 'LtSlashFill', 'SlashFill',
  28.    'BkSlashFill', 'LtBkSlashFill', 'HatchFill', 'XHatchFill',
  29.    'InterleaveFill', 'WideDotFill', 'CloseDotFill');
  30.  
  31.   { The two text directions available }
  32.   TextDirect : array[0..1] of string[8] = ('HorizDir', 'VertDir');
  33.  
  34.   { The Horizontal text justifications available }
  35.   HorizJust  : array[0..2] of string[10] = ('LeftText', 'CenterText', 'RightText');
  36.  
  37.   { The vertical text justifications available }
  38.   VertJust   : array[0..2] of string[10] = ('BottomText', 'CenterText', 'TopText');
  39.  
  40. var
  41.   GraphDriver : integer;  { The Graphics device driver }
  42.   GraphMode   : integer;  { The Graphics mode value }
  43.   MaxX, MaxY  : word;     { The maximum resolution of the screen }
  44.   ErrorCode   : integer;  { Reports any graphics errors }
  45.   MaxColor    : word;     { The maximum color value available }
  46.   OldExitProc : Pointer;  { Saves exit procedure address }
  47.  
  48. {$F+}
  49. procedure MyExitProc;
  50. begin
  51.   ExitProc := OldExitProc; { Restore exit procedure address }
  52.   CloseGraph;              { Shut down the graphics system }
  53. end; { MyExitProc }
  54. {$F-}
  55.  
  56. {$F+}
  57. function DetectVGA256 : integer;
  58. { Detects VGA or MCGA video cards }
  59. var
  60.   DetectedDriver : integer;
  61.   SuggestedMode  : integer;
  62. begin
  63.   DetectGraph(DetectedDriver, SuggestedMode);
  64.   if (DetectedDriver = VGA) or (DetectedDriver = MCGA) then
  65.   begin
  66.     Writeln('Which video mode would you like to use?');
  67.     Writeln('  0) 320x200x256');
  68.     Writeln('  1) 640x400x256');
  69.     Writeln('  2) 640x480x256');
  70.     Writeln('  3) 800x600x256');
  71.     Writeln('  4) 1024x768x256');
  72.     Write('> ');
  73.     Readln(SuggestedMode);
  74.     DetectVGA256 := SuggestedMode;
  75.   end
  76.   else
  77.     DetectVGA256 := grError; { Couldn't detect hardware }
  78. end; { DetectVGA256 }
  79. {$F-}
  80.  
  81. {$F+}
  82. function DetectTwk256 : integer;
  83. { Detects VGA or MCGA video cards }
  84. var
  85.   DetectedDriver : integer;
  86.   SuggestedMode  : integer;
  87. begin
  88.   DetectGraph(DetectedDriver, SuggestedMode);
  89.   if (DetectedDriver = VGA) or (DetectedDriver = MCGA) then
  90.   begin
  91.     Writeln('Which video mode would you like to use?');
  92.     Writeln('  0) 320x400x256');
  93.     Writeln('  1) 320x480x256');
  94.     Writeln('  2) 360x480x256');
  95.     Writeln('  3) 376x564x256');
  96.     Writeln('  4) 400x564x256');
  97.     Writeln('  5) 400x600x256');
  98.     Write('> ');
  99.     Readln(SuggestedMode);
  100.     DetectTwk256 := SuggestedMode;
  101.   end
  102.   else
  103.     DetectTwk256 := grError; { Couldn't detect hardware }
  104. end; { DetectVGA256 }
  105. {$F-}
  106.  
  107.  
  108. {$F+}
  109. function DetectVGA16 : integer;
  110. { Detects VGA or MCGA video cards }
  111. var
  112.   DetectedDriver : integer;
  113.   SuggestedMode  : integer;
  114. begin
  115.   DetectGraph(DetectedDriver, SuggestedMode);
  116.   if (DetectedDriver = EGA) or (DetectedDriver = VGA) then
  117.   begin
  118.     Writeln('Which video mode would you like to use?');
  119.     Writeln('  0) 320x200x16');
  120.     Writeln('  1) 640x200x16');
  121.     Writeln('  2) 640x350x16');
  122.     Writeln('  3) 640x480x16');
  123.     Writeln('  4) 800x600x16');
  124.     Writeln('  5) 1024x768x16');
  125.     Write('> ');
  126.     Readln(SuggestedMode);
  127.     DetectVGA16 := SuggestedMode;
  128.   end
  129.   else
  130.     DetectVGA16 := grError; { Couldn't detect hardware }
  131. end; { DetectVGA256 }
  132. {$F-}
  133.  
  134. {$F+}
  135. function DetectTwk16 : integer;
  136. { Detects VGA or MCGA video cards }
  137. var
  138.   DetectedDriver : integer;
  139.   SuggestedMode  : integer;
  140. begin
  141.   DetectGraph(DetectedDriver, SuggestedMode);
  142.   if (DetectedDriver = VGA) then
  143.   begin
  144.     Writeln('Which video mode would you like to use?');
  145.     Writeln('  0) 704x528x16');
  146.     Writeln('  1) 720x540x16');
  147.     Writeln('  2) 736x552x16');
  148.     Writeln('  3) 752x564x16');
  149.     Writeln('  4) 768x576x16');
  150.     Writeln('  5) 784x588x16');
  151.     Writeln('  6) 800x600x16');
  152.     Write('> ');
  153.     Readln(SuggestedMode);
  154.     DetectTwk16 := SuggestedMode;
  155.   end
  156.   else
  157.     DetectTwk16 := grError; { Couldn't detect hardware }
  158. end; { DetectVGA256 }
  159. {$F-}
  160.  
  161. var
  162.   AutoDetectPointer : pointer;
  163.  
  164. procedure Initialize;
  165. { Initialize graphics and report any errors that may occur }
  166. var
  167.   InGraphicsMode : boolean; { Flags initialization of graphics mode }
  168.   PathToDriver   : string;  { Stores the DOS path to *.BGI & *.CHR }
  169.   UseWhichDriver : integer;
  170. begin
  171.   { when using Crt and graphics, turn off Crt's memory-mapped writes }
  172.   DirectVideo := False;
  173.   OldExitProc := ExitProc;                { save previous exit proc }
  174.   ExitProc := @MyExitProc;                { insert our exit proc in chain }
  175.   PathToDriver := '';
  176.   repeat
  177.     Writeln('Which driver to use?');
  178.     Writeln('  0) Svga256');
  179.     Writeln('  1) Svga16');
  180.     Writeln('  2) Tweak256');
  181.     Writeln('  3) Tweak16');
  182.     Write('>');
  183.     Readln(UseWhichDriver);
  184.     if (UseWhichDriver = 0) then
  185.     begin
  186.       AutoDetectPointer := @DetectVGA256;
  187.       GraphDriver := InstallUserDriver('Svga256',AutoDetectPointer);
  188.     end
  189.     else if (UseWhichDriver=1) then
  190.     begin
  191.       AutoDetectPointer := @DetectVGA16;   { Point to detection routine }
  192.       GraphDriver := InstallUserDriver('SVGA16', AutoDetectPointer);
  193.     end
  194.     else if (UseWhichDriver=2) then
  195.     begin
  196.       AutoDetectPointer := @DetectTwk256;
  197.       GraphDriver := InstallUserDriver('Twk256',AutoDetectPointer);
  198.     end
  199.     else if (UseWhichDriver=3) then
  200.     begin
  201.       AutoDetectPointer := @DetectTwk16;
  202.       GraphDriver := InstallUserDriver('Twk16',AutoDetectPointer);
  203.     end;
  204.     GraphDriver := Detect;
  205.     InitGraph(GraphDriver, GraphMode, PathToDriver);
  206.     ErrorCode := GraphResult;             { preserve error return }
  207.     if ErrorCode <> grOK then             { error? }
  208.     begin
  209.       Writeln('Graphics error: ', GraphErrorMsg(ErrorCode));
  210.       if ErrorCode = grFileNotFound then  { Can't find driver file }
  211.       begin
  212.         Writeln('Enter full path to BGI driver or type <Ctrl-Break> to quit:');
  213.         Readln(PathToDriver);
  214.         Writeln;
  215.       end
  216.       else
  217.         Halt(1);                          { Some other error: terminate }
  218.     end;
  219.   until ErrorCode = grOK;
  220.   Randomize;                { init random number generator }
  221.   MaxColor := GetMaxColor;  { Get the maximum allowable drawing color }
  222.   MaxX := GetMaxX;          { Get screen resolution values }
  223.   MaxY := GetMaxY;
  224. end; { Initialize }
  225.  
  226. function Int2Str(L : LongInt) : string;
  227. { Converts an integer to a string for use with OutText, OutTextXY }
  228. var
  229.   S : string;
  230. begin
  231.   Str(L, S);
  232.   Int2Str := S;
  233. end; { Int2Str }
  234.  
  235. function RandColor : word;
  236. { Returns a Random non-zero color value that is within the legal
  237.   color range for the selected device driver and graphics mode.
  238.   MaxColor is set to GetMaxColor by Initialize }
  239. begin
  240.   RandColor := Random(MaxColor)+1;
  241. end; { RandColor }
  242.  
  243. procedure DefaultColors;
  244. { Select the maximum color in the Palette for the drawing color }
  245. begin
  246.   SetColor(White);
  247. end; { DefaultColors }
  248.  
  249. procedure DrawBorder;
  250. { Draw a border around the current view port }
  251. var
  252.   ViewPort : ViewPortType;
  253. begin
  254.   DefaultColors;
  255.   SetLineStyle(SolidLn, 0, NormWidth);
  256.   GetViewSettings(ViewPort);
  257.   with ViewPort do
  258.     Rectangle(0, 0, x2-x1, y2-y1);
  259. end; { DrawBorder }
  260.  
  261. procedure FullPort;
  262. { Set the view port to the entire screen }
  263. begin
  264.   SetViewPort(0, 0, MaxX, MaxY, ClipOn);
  265. end; { FullPort }
  266.  
  267. procedure MainWindow(Header : string);
  268. { Make a default window and view port for demos }
  269. begin
  270.   DefaultColors;                           { Reset the colors }
  271.   ClearDevice;                             { Clear the screen }
  272.   SetTextStyle(DefaultFont, HorizDir, 1);  { Default text font }
  273.   SetTextJustify(CenterText, TopText);     { Left justify text }
  274.   FullPort;                                { Full screen view port }
  275.   OutTextXY(MaxX div 2, 2, Header);        { Draw the header }
  276.   { Draw main window }
  277.   SetViewPort(0, TextHeight('M')+4, MaxX, MaxY-(TextHeight('M')+4), ClipOn);
  278.   DrawBorder;                              { Put a border around it }
  279.   { Move the edges in 1 pixel on all sides so border isn't in the view port }
  280.   SetViewPort(1, TextHeight('M')+5, MaxX-1, MaxY-(TextHeight('M')+5), ClipOn);
  281. end; { MainWindow }
  282.  
  283. procedure StatusLine(Msg : string);
  284. { Display a status line at the bottom of the screen }
  285. begin
  286.   FullPort;
  287.   DefaultColors;
  288.   SetTextStyle(DefaultFont, HorizDir, 1);
  289.   SetTextJustify(CenterText, TopText);
  290.   SetLineStyle(SolidLn, 0, NormWidth);
  291.   SetFillStyle(EmptyFill, 0);
  292.   Bar(0, MaxY-(TextHeight('M')+4), MaxX, MaxY);      { Erase old status line }
  293.   Rectangle(0, MaxY-(TextHeight('M')+4), MaxX, MaxY);
  294.   OutTextXY(MaxX div 2, MaxY-(TextHeight('M')+2), Msg);
  295.   { Go back to the main window }
  296.   SetViewPort(1, TextHeight('M')+5, MaxX-1, MaxY-(TextHeight('M')+5), ClipOn);
  297. end; { StatusLine }
  298.  
  299. procedure WaitToGo;
  300. { Wait for the user to abort the program or continue }
  301. const
  302.   Esc = #27;
  303. var
  304.   Ch : char;
  305. begin
  306.   StatusLine('Esc aborts or press a key...');
  307.   repeat until KeyPressed;
  308.   Ch := ReadKey;
  309.   if Ch = Esc then
  310.     Halt(0)                           { terminate program }
  311.   else
  312.     ClearDevice;                      { clear screen, go on with demo }
  313. end; { WaitToGo }
  314.  
  315. procedure GetDriverAndMode(var DriveStr, ModeStr : string);
  316. { Return strings describing the current device driver and graphics mode
  317.   for display of status report }
  318. begin
  319.   DriveStr := GetDriverName;
  320.   ModeStr := GetModeName(GetGraphMode);
  321. end; { GetDriverAndMode }
  322.  
  323. procedure ReportStatus;
  324. { Display the status of all query functions after InitGraph }
  325. const
  326.   X = 10;
  327. var
  328.   ViewInfo   : ViewPortType;     { Parameters for inquiry procedures }
  329.   LineInfo   : LineSettingsType;
  330.   FillInfo   : FillSettingsType;
  331.   TextInfo   : TextSettingsType;
  332.   Palette    : PaletteType;
  333.   DriverStr  : string;           { Driver and mode strings }
  334.   ModeStr    : string;
  335.   Y          : word;
  336.  
  337. procedure WriteOut(S : string);
  338. { Write out a string and increment to next line }
  339. begin
  340.   OutTextXY(X, Y, S);
  341.   Inc(Y, TextHeight('M')+2);
  342. end; { WriteOut }
  343.  
  344. begin { ReportStatus }
  345.   GetDriverAndMode(DriverStr, ModeStr);   { Get current settings }
  346.   GetViewSettings(ViewInfo);
  347.   GetLineSettings(LineInfo);
  348.   GetFillSettings(FillInfo);
  349.   GetTextSettings(TextInfo);
  350.   GetPalette(Palette);
  351.  
  352.   Y := 4;
  353.   MainWindow('Status report after InitGraph');
  354.   SetTextJustify(LeftText, TopText);
  355.   WriteOut('Graphics device    : '+DriverStr);
  356.   WriteOut('Graphics mode      : '+ModeStr);
  357.   WriteOut('Screen resolution  : (0, 0, '+Int2Str(GetMaxX)+', '+Int2Str(GetMaxY)+')');
  358.   with ViewInfo do
  359.   begin
  360.     WriteOut('Current view port  : ('+Int2Str(x1)+', '+Int2Str(y1)+', '+Int2Str(x2)+', '+Int2Str(y2)+')');
  361.     if ClipOn then
  362.       WriteOut('Clipping           : ON')
  363.     else
  364.       WriteOut('Clipping           : OFF');
  365.   end;
  366.   WriteOut('Current position   : ('+Int2Str(GetX)+', '+Int2Str(GetY)+')');
  367.   WriteOut('Palette entries    : '+Int2Str(Palette.Size));
  368.   WriteOut('GetMaxColor        : '+Int2Str(GetMaxColor));
  369.   WriteOut('Current color      : '+Int2Str(GetColor));
  370.   with LineInfo do
  371.   begin
  372.     WriteOut('Line style         : '+LineStyles[LineStyle]);
  373.     WriteOut('Line thickness     : '+Int2Str(Thickness));
  374.   end;
  375.   with FillInfo do
  376.   begin
  377.     WriteOut('Current fill style : '+FillStyles[Pattern]);
  378.     WriteOut('Current fill color : '+Int2Str(Color));
  379.   end;
  380.   with TextInfo do
  381.   begin
  382.     WriteOut('Current font       : '+Fonts[Font]);
  383.     WriteOut('Text direction     : '+TextDirect[Direction]);
  384.     WriteOut('Character size     : '+Int2Str(CharSize));
  385.     WriteOut('Horizontal justify : '+HorizJust[Horiz]);
  386.     WriteOut('Vertical justify   : '+VertJust[Vert]);
  387.   end;
  388.   WaitToGo;
  389. end; { ReportStatus }
  390.  
  391. procedure FillEllipsePlay;
  392. { Random filled ellipse demonstration }
  393. const
  394.   MaxFillStyles = 12; { patterns 0..11 }
  395. var
  396.   MaxRadius : word;
  397.   FillColor : integer;
  398. begin
  399.   MainWindow('FillEllipse demonstration');
  400.   StatusLine('Esc aborts or press a key');
  401.   MaxRadius := MaxY div 10;
  402.   SetLineStyle(SolidLn, 0, NormWidth);
  403.   repeat
  404.     FillColor := RandColor;
  405.     SetColor(FillColor);
  406.     SetFillStyle(Random(MaxFillStyles), FillColor);
  407.     FillEllipse(Random(MaxX), Random(MaxY),
  408.                 Random(MaxRadius), Random(MaxRadius));
  409.   until KeyPressed;
  410.   WaitToGo;
  411. end; { FillEllipsePlay }
  412.  
  413. procedure SectorPlay;
  414. { Draw random sectors on the screen }
  415. const
  416.   MaxFillStyles = 12; { patterns 0..11 }
  417. var
  418.   MaxRadius : word;
  419.   FillColor : integer;
  420.   EndAngle  : integer;
  421. begin
  422.   MainWindow('Sector demonstration');
  423.   StatusLine('Esc aborts or press a key');
  424.   MaxRadius := MaxY div 10;
  425.   SetLineStyle(SolidLn, 0, NormWidth);
  426.   repeat
  427.     FillColor := RandColor;
  428.     SetColor(FillColor);
  429.     SetFillStyle(Random(MaxFillStyles), FillColor);
  430.     EndAngle := Random(360);
  431.     Sector(Random(MaxX), Random(MaxY), Random(EndAngle), EndAngle,
  432.            Random(MaxRadius), Random(MaxRadius));
  433.   until KeyPressed;
  434.   WaitToGo;
  435. end; { SectorPlay }
  436.  
  437. procedure WriteModePlay;
  438. { Demonstrate the SetWriteMode procedure for XOR lines }
  439. const
  440.   DelayValue = 50;  { milliseconds to delay }
  441. var
  442.   ViewInfo      : ViewPortType;
  443.   Color         : word;
  444.   Left, Top     : integer;
  445.   Right, Bottom : integer;
  446.   Step          : integer; { step for rectangle shrinking }
  447. begin
  448.   MainWindow('SetWriteMode demonstration');
  449.   StatusLine('Esc aborts or press a key');
  450.   GetViewSettings(ViewInfo);
  451.   Left := 0;
  452.   Top := 0;
  453.   with ViewInfo do
  454.   begin
  455.     Right := x2-x1;
  456.     Bottom := y2-y1;
  457.   end;
  458.   Step := Bottom div 50;
  459.   SetColor(White);
  460.   Line(Left, Top, Right, Bottom);
  461.   Line(Left, Bottom, Right, Top);
  462.   SetWriteMode(XORPut);                    { Set XOR write mode }
  463.   repeat
  464.     Line(Left, Top, Right, Bottom);        { Draw XOR lines }
  465.     Line(Left, Bottom, Right, Top);
  466.     Rectangle(Left, Top, Right, Bottom);   { Draw XOR rectangle }
  467.     Delay(DelayValue);                     { Wait }
  468.     Line(Left, Top, Right, Bottom);        { Erase lines }
  469.     Line(Left, Bottom, Right, Top);
  470.     Rectangle(Left, Top, Right, Bottom);   { Erase rectangle }
  471.     if (Left+Step < Right) and (Top+Step < Bottom) then
  472.       begin
  473.         Inc(Left, Step);                  { Shrink rectangle }
  474.         Inc(Top, Step);
  475.         Dec(Right, Step);
  476.         Dec(Bottom, Step);
  477.       end
  478.     else
  479.       begin
  480.         Color := RandColor;                { New color }
  481.         SetColor(Color);
  482.         Left := 0;                         { Original large rectangle }
  483.         Top := 0;
  484.         with ViewInfo do
  485.         begin
  486.           Right := x2-x1;
  487.           Bottom := y2-y1;
  488.         end;
  489.       end;
  490.   until KeyPressed;
  491.   SetWriteMode(CopyPut);                   { back to overwrite mode }
  492.   WaitToGo;
  493. end; { WriteModePlay }
  494.  
  495. procedure AspectRatioPlay;
  496. { Demonstrate  SetAspectRatio command }
  497. var
  498.   ViewInfo   : ViewPortType;
  499.   CenterX    : integer;
  500.   CenterY    : integer;
  501.   Radius     : word;
  502.   Xasp, Yasp : word;
  503.   i          : integer;
  504.   RadiusStep : word;
  505. begin
  506.   MainWindow('SetAspectRatio demonstration');
  507.   GetViewSettings(ViewInfo);
  508.   with ViewInfo do
  509.   begin
  510.     CenterX := (x2-x1) div 2;
  511.     CenterY := (y2-y1) div 2;
  512.     Radius := 3*((y2-y1) div 5);
  513.   end;
  514.   RadiusStep := (Radius div 30);
  515.   Circle(CenterX, CenterY, Radius);
  516.   GetAspectRatio(Xasp, Yasp);
  517.   for i := 1 to 30 do
  518.   begin
  519.     SetAspectRatio(Xasp, Yasp+(I*GetMaxX));    { Increase Y aspect factor }
  520.     Circle(CenterX, CenterY, Radius);
  521.     Dec(Radius, RadiusStep);                   { Shrink radius }
  522.   end;
  523.   Inc(Radius, RadiusStep*30);
  524.   for i := 1 to 30 do
  525.   begin
  526.     SetAspectRatio(Xasp+(I*GetMaxX), Yasp);    { Increase X aspect factor }
  527.     if Radius > RadiusStep then
  528.       Dec(Radius, RadiusStep);                 { Shrink radius }
  529.     Circle(CenterX, CenterY, Radius);
  530.   end;
  531.   SetAspectRatio(Xasp, Yasp);                  { back to original aspect }
  532.   WaitToGo;
  533. end; { AspectRatioPlay }
  534.  
  535. procedure TextPlay;
  536. { Demonstrate text justifications and text sizing }
  537. var
  538.   Size : word;
  539.   W, H, X, Y : word;
  540.   ViewInfo : ViewPortType;
  541. begin
  542.   MainWindow('SetTextJustify / SetUserCharSize demo');
  543.   GetViewSettings(ViewInfo);
  544.   with ViewInfo do
  545.   begin
  546.     SetTextStyle(TriplexFont, VertDir, 4);
  547.     Y := (y2-y1) - 2;
  548.     SetTextJustify(CenterText, BottomText);
  549.     OutTextXY(2*TextWidth('M'), Y, 'Vertical');
  550.     SetTextStyle(TriplexFont, HorizDir, 4);
  551.     SetTextJustify(LeftText, TopText);
  552.     OutTextXY(2*TextWidth('M'), 2, 'Horizontal');
  553.     SetTextJustify(CenterText, CenterText);
  554.     X := (x2-x1) div 2;
  555.     Y := TextHeight('H');
  556.     for Size := 1 to 4 do
  557.     begin
  558.       SetTextStyle(TriplexFont, HorizDir, Size);
  559.       H := TextHeight('M');
  560.       W := TextWidth('M');
  561.       Inc(Y, H);
  562.       OutTextXY(X, Y, 'Size '+Int2Str(Size));
  563.     end;
  564.     Inc(Y, H div 2);
  565.     SetTextJustify(CenterText, TopText);
  566.     SetUserCharSize(5, 6, 3, 2);
  567.     SetTextStyle(TriplexFont, HorizDir, UserCharSize);
  568.     OutTextXY((x2-x1) div 2, Y, 'User defined size!');
  569.   end;
  570.   WaitToGo;
  571. end; { TextPlay }
  572.  
  573. procedure TextDump;
  574. { Dump the complete character sets to the screen }
  575. const
  576.   CGASizes  : array[0..4] of word = (1, 3, 7, 3, 3);
  577.   NormSizes : array[0..4] of word = (1, 4, 7, 4, 4);
  578. var
  579.   Font : word;
  580.   ViewInfo : ViewPortType;
  581.   Ch : char;
  582. begin
  583.   for Font := 0 to 4 do
  584.   begin
  585.     MainWindow(Fonts[Font]+' character set');
  586.     GetViewSettings(ViewInfo);
  587.     with ViewInfo do
  588.     begin
  589.       SetTextJustify(LeftText, TopText);
  590.       MoveTo(2, 3);
  591.       if Font = DefaultFont then
  592.         begin
  593.           SetTextStyle(Font, HorizDir, 1);
  594.           Ch := #0;
  595.           repeat
  596.             OutText(Ch);
  597.             if (GetX + TextWidth('M')) > (x2-x1) then
  598.               MoveTo(2, GetY + TextHeight('M')+3);
  599.             Ch := Succ(Ch);
  600.           until (Ch >= #255);
  601.         end
  602.       else
  603.         begin
  604.           if MaxY < 200 then
  605.             SetTextStyle(Font, HorizDir, CGASizes[Font])
  606.           else
  607.             SetTextStyle(Font, HorizDir, NormSizes[Font]);
  608.           Ch := '!';
  609.           repeat
  610.             OutText(Ch);
  611.             if (GetX + TextWidth('M')) > (x2-x1) then
  612.               MoveTo(2, GetY + TextHeight('M')+3);
  613.             Ch := Succ(Ch);
  614.           until (Ord(Ch) = Ord('~')+1);
  615.         end;
  616.     end; { with }
  617.     WaitToGo;
  618.   end; { for loop }
  619. end; { TextDump }
  620.  
  621. procedure LineToPlay;
  622. { Demonstrate MoveTo and LineTo commands }
  623. const
  624.   MaxPoints = 15;
  625. var
  626.   Points     : array[0..MaxPoints] of PointType;
  627.   ViewInfo   : ViewPortType;
  628.   I, J       : integer;
  629.   CenterX    : integer;   { The center point of the circle }
  630.   CenterY    : integer;
  631.   Radius     : word;
  632.   StepAngle  : word;
  633.   Xasp, Yasp : word;
  634.   Radians    : real;
  635.  
  636. function AdjAsp(Value : integer) : integer;
  637. { Adjust a value for the aspect ratio of the device }
  638. begin
  639.   AdjAsp := (LongInt(Value) * Xasp) div Yasp;
  640. end; { AdjAsp }
  641.  
  642. begin
  643.   MainWindow('MoveTo, LineTo demonstration');
  644.   GetAspectRatio(Xasp, Yasp);
  645.   GetViewSettings(ViewInfo);
  646.   with ViewInfo do
  647.   begin
  648.     CenterX := (x2-x1) div 2;
  649.     CenterY := (y2-y1) div 2;
  650.     Radius := CenterY;
  651.     while (CenterY+AdjAsp(Radius)) < (y2-y1)-20 do
  652.       Inc(Radius);
  653.   end;
  654.   StepAngle := 360 div MaxPoints;
  655.   for I := 0 to MaxPoints - 1 do
  656.   begin
  657.     Radians := (StepAngle * I) * Pi / 180;
  658.     Points[I].X := CenterX + round(Cos(Radians) * Radius);
  659.     Points[I].Y := CenterY - AdjAsp(round(Sin(Radians) * Radius));
  660.   end;
  661.   Circle(CenterX, CenterY, Radius);
  662.   for I := 0 to MaxPoints - 1 do
  663.   begin
  664.     for J := I to MaxPoints - 1 do
  665.     begin
  666.       MoveTo(Points[I].X, Points[I].Y);
  667.       LineTo(Points[J].X, Points[J].Y);
  668.     end;
  669.   end;
  670.   WaitToGo;
  671. end; { LineToPlay }
  672.  
  673. procedure LineRelPlay;
  674. { Demonstrate MoveRel and LineRel commands }
  675. const
  676.   MaxPoints = 12;
  677. var
  678.   Poly     : array[1..MaxPoints] of PointType; { Stores a polygon for filling }
  679.   CurrPort : ViewPortType;
  680.  
  681. procedure DrawTesseract;
  682. { Draw a Tesseract on the screen with relative move and
  683.   line drawing commands, also create a polygon for filling }
  684. const
  685.   CheckerBoard : FillPatternType = (0, $10, $28, $44, $28, $10, 0, 0);
  686. var
  687.   X, Y, W, H   : integer;
  688.  
  689. begin
  690.   GetViewSettings(CurrPort);
  691.   with CurrPort do
  692.   begin
  693.     W := (x2-x1) div 9;
  694.     H := (y2-y1) div 8;
  695.     X := ((x2-x1) div 2) - round(2.5 * W);
  696.     Y := ((y2-y1) div 2) - (3 * H);
  697.  
  698.     { Border around viewport is outer part of polygon }
  699.     Poly[1].X := 0;     Poly[1].Y := 0;
  700.     Poly[2].X := x2-x1; Poly[2].Y := 0;
  701.     Poly[3].X := x2-x1; Poly[3].Y := y2-y1;
  702.     Poly[4].X := 0;     Poly[4].Y := y2-y1;
  703.     Poly[5].X := 0;     Poly[5].Y := 0;
  704.     MoveTo(X, Y);
  705.  
  706.     { Grab the whole in the polygon as we draw }
  707.     MoveRel(0, H);      Poly[6].X := GetX;  Poly[6].Y := GetY;
  708.     MoveRel(W, -H);     Poly[7].X := GetX;  Poly[7].Y := GetY;
  709.     MoveRel(4*W, 0);    Poly[8].X := GetX;  Poly[8].Y := GetY;
  710.     MoveRel(0, 5*H);    Poly[9].X := GetX;  Poly[9].Y := GetY;
  711.     MoveRel(-W, H);     Poly[10].X := GetX; Poly[10].Y := GetY;
  712.     MoveRel(-4*W, 0);   Poly[11].X := GetX; Poly[11].Y := GetY;
  713.     MoveRel(0, -5*H);   Poly[12].X := GetX; Poly[12].Y := GetY;
  714.  
  715.     { Fill the polygon with a user defined fill pattern }
  716.     SetFillPattern(CheckerBoard, Green);
  717.     FillPoly(12, Poly);
  718.  
  719.     MoveRel(W, -H);
  720.     LineRel(0, 5*H);   LineRel(2*W, 0);    LineRel(0, -3*H);
  721.     LineRel(W, -H);    LineRel(0, 5*H);    MoveRel(0, -5*H);
  722.     LineRel(-2*W, 0);  LineRel(0, 3*H);    LineRel(-W, H);
  723.     MoveRel(W, -H);    LineRel(W, 0);      MoveRel(0, -2*H);
  724.     LineRel(-W, 0);
  725.  
  726.     { Flood fill the center }
  727.     FloodFill((x2-x1) div 2, (y2-y1) div 2,15);
  728.   end;
  729. end; { DrawTesseract }
  730.  
  731. begin
  732.   MainWindow('LineRel / MoveRel demonstration');
  733.   GetViewSettings(CurrPort);
  734.   with CurrPort do
  735.     { Move the viewport out 1 pixel from each end }
  736.     SetViewPort(x1-1, y1-1, x2+1, y2+1, ClipOn);
  737.   DrawTesseract;
  738.   WaitToGo;
  739. end; { LineRelPlay }
  740.  
  741. procedure PiePlay;
  742. { Demonstrate  PieSlice and GetAspectRatio commands }
  743. var
  744.   ViewInfo   : ViewPortType;
  745.   CenterX    : integer;
  746.   CenterY    : integer;
  747.   Radius     : word;
  748.   Xasp, Yasp : word;
  749.   X, Y       : integer;
  750.  
  751. function AdjAsp(Value : integer) : integer;
  752. { Adjust a value for the aspect ratio of the device }
  753. begin
  754.   AdjAsp := (LongInt(Value) * Xasp) div Yasp;
  755. end; { AdjAsp }
  756.  
  757. procedure GetTextCoords(AngleInDegrees, Radius : word; var X, Y : integer);
  758. { Get the coordinates of text for pie slice labels }
  759. var
  760.   Radians : real;
  761. begin
  762.   Radians := AngleInDegrees * Pi / 180;
  763.   X := round(Cos(Radians) * Radius);
  764.   Y := round(Sin(Radians) * Radius);
  765. end; { GetTextCoords }
  766.  
  767. begin
  768.   MainWindow('PieSlice / GetAspectRatio demonstration');
  769.   GetAspectRatio(Xasp, Yasp);
  770.   GetViewSettings(ViewInfo);
  771.   with ViewInfo do
  772.   begin
  773.     CenterX := (x2-x1) div 2;
  774.     CenterY := ((y2-y1) div 2) + 20;
  775.     Radius := (y2-y1) div 3;
  776.     while AdjAsp(Radius) < round((y2-y1) / 3.6) do
  777.       Inc(Radius);
  778.   end;
  779.   SetTextStyle(TriplexFont, HorizDir, 4);
  780.   SetTextJustify(CenterText, TopText);
  781.   OutTextXY(CenterX, 0, 'This is a pie chart!');
  782.  
  783.   SetTextStyle(TriplexFont, HorizDir, 3);
  784.  
  785.   SetFillStyle(SolidFill, RandColor);
  786.   PieSlice(CenterX+10, CenterY-AdjAsp(10), 0, 90, Radius);
  787.   GetTextCoords(45, Radius, X, Y);
  788.   SetTextJustify(LeftText, BottomText);
  789.   OutTextXY(CenterX+10+X+TextWidth('H'), CenterY-AdjAsp(10+Y), '25 %');
  790.  
  791.   SetFillStyle(HatchFill, RandColor);
  792.   PieSlice(CenterX, CenterY, 225, 360, Radius);
  793.   GetTextCoords(293, Radius, X, Y);
  794.   SetTextJustify(LeftText, TopText);
  795.   OutTextXY(CenterX+X+TextWidth('H'), CenterY-AdjAsp(Y), '37.5 %');
  796.  
  797.   SetFillStyle(InterleaveFill, RandColor);
  798.   PieSlice(CenterX-10, CenterY, 135, 225, Radius);
  799.   GetTextCoords(180, Radius, X, Y);
  800.   SetTextJustify(RightText, CenterText);
  801.   OutTextXY(CenterX-10+X-TextWidth('H'), CenterY-AdjAsp(Y), '25 %');
  802.  
  803.   SetFillStyle(WideDotFill, RandColor);
  804.   PieSlice(CenterX, CenterY, 90, 135, Radius);
  805.   GetTextCoords(112, Radius, X, Y);
  806.   SetTextJustify(RightText, BottomText);
  807.   OutTextXY(CenterX+X-TextWidth('H'), CenterY-AdjAsp(Y), '12.5 %');
  808.  
  809.   WaitToGo;
  810. end; { PiePlay }
  811.  
  812. procedure Bar3DPlay;
  813. { Demonstrate Bar3D command }
  814. const
  815.   NumBars   = 7;  { The number of bars drawn }
  816.   BarHeight : array[1..NumBars] of byte = (1, 3, 2, 5, 4, 2, 1);
  817.   YTicks    = 5;  { The number of tick marks on the Y axis }
  818. var
  819.   ViewInfo : ViewPortType;
  820.   H        : word;
  821.   XStep    : real;
  822.   YStep    : real;
  823.   I, J     : integer;
  824.   Depth    : word;
  825.   Color    : word;
  826. begin
  827.   MainWindow('Bar3D / Rectangle demonstration');
  828.   H := 3*TextHeight('M');
  829.   GetViewSettings(ViewInfo);
  830.   SetTextJustify(CenterText, TopText);
  831.   SetTextStyle(TriplexFont, HorizDir, 4);
  832.   OutTextXY(MaxX div 2, 6, 'These are 3D bars !');
  833.   SetTextStyle(DefaultFont, HorizDir, 1);
  834.   with ViewInfo do
  835.     SetViewPort(x1+50, y1+40, x2-50, y2-10, ClipOn);
  836.   GetViewSettings(ViewInfo);
  837.   with ViewInfo do
  838.   begin
  839.     Line(H, H, H, (y2-y1)-H);
  840.     Line(H, (y2-y1)-H, (x2-x1)-H, (y2-y1)-H);
  841.     YStep := ((y2-y1)-(2*H)) / YTicks;
  842.     XStep := ((x2-x1)-(2*H)) / NumBars;
  843.     J := (y2-y1)-H;
  844.     SetTextJustify(CenterText, CenterText);
  845.  
  846.     { Draw the Y axis and ticks marks }
  847.     for I := 0 to Yticks do
  848.     begin
  849.       Line(H div 2, J, H, J);
  850.       OutTextXY(0, J, Int2Str(I));
  851.       J := Round(J-Ystep);
  852.     end;
  853.  
  854.  
  855.     Depth := trunc(0.25 * XStep);    { Calculate depth of bar }
  856.  
  857.     { Draw X axis, bars, and tick marks }
  858.     SetTextJustify(CenterText, TopText);
  859.     J := H;
  860.     for I := 1 to Succ(NumBars) do
  861.     begin
  862.       SetColor(White);
  863.       Line(J, (y2-y1)-H, J, (y2-y1-3)-(H div 2));
  864.       OutTextXY(J, (y2-y1)-(H div 2), Int2Str(I-1));
  865.       if I <> Succ(NumBars) then
  866.       begin
  867.         Color := RandColor;
  868.         SetFillStyle(I, Color);
  869.         SetColor(Color);
  870.         Bar3D(J, round((y2-y1-H)-(BarHeight[I] * Ystep)),
  871.                  round(J+Xstep-Depth), round((y2-y1)-H-1), Depth, TopOn);
  872.         J := Round(J+Xstep);
  873.       end;
  874.     end;
  875.  
  876.   end;
  877.   WaitToGo;
  878. end; { Bar3DPlay }
  879.  
  880. procedure SolidBarPlay;
  881. { Draw random solid bars on the screen }
  882. var
  883.   MaxWidth  : integer;
  884.   MaxHeight : integer;
  885.   ViewInfo  : ViewPortType;
  886.   Color     : word;
  887. begin
  888.   MainWindow('Random Solid Bars');
  889.   StatusLine('Esc aborts or press a key');
  890.   GetViewSettings(ViewInfo);
  891.   with ViewInfo do
  892.   begin
  893.     MaxWidth := x2-x1;
  894.     MaxHeight := y2-y1;
  895.   end;
  896.   repeat
  897.     Color := Random(256);  { RandColor }
  898.     SetColor(Color);
  899.     SetFillStyle(SolidFill, Color);
  900.     Bar3D(Random(MaxWidth), Random(MaxHeight),
  901.           Random(MaxWidth), Random(MaxHeight), 0, TopOff);
  902.   until KeyPressed;
  903.   WaitToGo;
  904. end; { SolidBarPlay }
  905.  
  906. procedure BarPlay;
  907. { Demonstrate Bar command }
  908. const
  909.   NumBars   = 5;
  910.   BarHeight : array[1..NumBars] of byte = (1, 3, 5, 2, 4);
  911.   Styles    : array[1..NumBars] of byte = (1, 3, 10, 5, 9);
  912. var
  913.   ViewInfo  : ViewPortType;
  914.   BarNum    : word;
  915.   H         : word;
  916.   XStep     : real;
  917.   YStep     : real;
  918.   I, J      : integer;
  919.   Color     : word;
  920. begin
  921.   MainWindow('Bar / Rectangle demonstration');
  922.   H := 3*TextHeight('M');
  923.   GetViewSettings(ViewInfo);
  924.   SetTextJustify(CenterText, TopText);
  925.   SetTextStyle(TriplexFont, HorizDir, 4);
  926.   OutTextXY(MaxX div 2, 6, 'These are 2D bars !');
  927.   SetTextStyle(DefaultFont, HorizDir, 1);
  928.   with ViewInfo do
  929.     SetViewPort(x1+50, y1+30, x2-50, y2-10, ClipOn);
  930.   GetViewSettings(ViewInfo);
  931.   with ViewInfo do
  932.   begin
  933.     Line(H, H, H, (y2-y1)-H);
  934.     Line(H, (y2-y1)-H, (x2-x1)-H, (y2-y1)-H);
  935.     YStep := ((y2-y1)-(2*H)) / NumBars;
  936.     XStep := ((x2-x1)-(2*H)) / NumBars;
  937.     J := (y2-y1)-H;
  938.     SetTextJustify(CenterText, CenterText);
  939.  
  940.     { Draw Y axis with tick marks }
  941.     for I := 0 to NumBars do
  942.     begin
  943.       Line(H div 2, J, H, J);
  944.       OutTextXY(0, J, Int2Str(i));
  945.       J := Round(J-Ystep);
  946.     end;
  947.  
  948.     { Draw X axis, bars, and tick marks }
  949.     J := H;
  950.     SetTextJustify(CenterText, TopText);
  951.     for I := 1 to Succ(NumBars) do
  952.     begin
  953.       SetColor(White);
  954.       Line(J, (y2-y1)-H, J, (y2-y1-3)-(H div 2));
  955.       OutTextXY(J, (y2-y1)-(H div 2), Int2Str(I));
  956.       if I <> Succ(NumBars) then
  957.       begin
  958.         Color := RandColor;
  959.         SetFillStyle(Styles[I], Color);
  960.         SetColor(Color);
  961.         Bar(J, round((y2-y1-H)-(BarHeight[I] * Ystep)), round(J+Xstep), (y2-y1)-H-1);
  962.         Rectangle(J, round((y2-y1-H)-(BarHeight[I] * Ystep)), round(J+Xstep), (y2-y1)-H-1);
  963.       end;
  964.       J := Round(J+Xstep);
  965.     end;
  966.  
  967.   end;
  968.   WaitToGo;
  969. end; { BarPlay }
  970.  
  971. procedure CirclePlay;
  972. { Draw random circles on the screen }
  973. var
  974.   MaxRadius : word;
  975. begin
  976.   MainWindow('Circle demonstration');
  977.   StatusLine('Esc aborts or press a key');
  978.   MaxRadius := MaxY div 10;
  979.   SetLineStyle(SolidLn, 0, NormWidth);
  980.   repeat
  981.     SetColor(RandColor);
  982.     Circle(Random(MaxX), Random(MaxY), Random(MaxRadius));
  983.   until KeyPressed;
  984.   WaitToGo;
  985. end; { CirclePlay }
  986.  
  987.  
  988. procedure RandBarPlay;
  989. { Draw random bars on the screen }
  990. var
  991.   MaxWidth  : integer;
  992.   MaxHeight : integer;
  993.   ViewInfo  : ViewPortType;
  994.   Color     : word;
  995. begin
  996.   MainWindow('Random Bars');
  997.   StatusLine('Esc aborts or press a key');
  998.   GetViewSettings(ViewInfo);
  999.   with ViewInfo do
  1000.   begin
  1001.     MaxWidth := x2-x1;
  1002.     MaxHeight := y2-y1;
  1003.   end;
  1004.   repeat
  1005.     Color := RandColor;
  1006.     SetColor(Color);
  1007.     SetFillStyle(Random(CloseDotFill)+1, Color);
  1008.     Bar3D(Random(MaxWidth), Random(MaxHeight),
  1009.           Random(MaxWidth), Random(MaxHeight), 0, TopOff);
  1010.   until KeyPressed;
  1011.   WaitToGo;
  1012. end; { RandBarPlay }
  1013.  
  1014. procedure ArcPlay;
  1015. { Draw random arcs on the screen }
  1016. var
  1017.   MaxRadius : word;
  1018.   EndAngle : word;
  1019.   ArcInfo : ArcCoordsType;
  1020. begin
  1021.   MainWindow('Arc / GetArcCoords demonstration');
  1022.   StatusLine('Esc aborts or press a key');
  1023.   MaxRadius := MaxY div 10;
  1024.   repeat
  1025.     SetColor(RandColor);
  1026.     EndAngle := Random(360);
  1027.     SetLineStyle(SolidLn, 0, NormWidth);
  1028.     Arc(Random(MaxX), Random(MaxY), Random(EndAngle), EndAngle, Random(MaxRadius));
  1029.     GetArcCoords(ArcInfo);
  1030.     with ArcInfo do
  1031.     begin
  1032.       Line(X, Y, XStart, YStart);
  1033.       Line(X, Y, Xend, Yend);
  1034.     end;
  1035.   until KeyPressed;
  1036.   WaitToGo;
  1037. end; { ArcPlay }
  1038.  
  1039. procedure PutPixelPlay;
  1040. { Demonstrate the PutPixel and GetPixel commands }
  1041. const
  1042.   Seed   = 1962; { A seed for the random number generator }
  1043.   NumPts = 2000; { The number of pixels plotted }
  1044.   Esc    = #27;
  1045. var
  1046.   I : word;
  1047.   X, Y, Color : word;
  1048.   XMax, YMax  : integer;
  1049.   ViewInfo    : ViewPortType;
  1050. begin
  1051.   MainWindow('PutPixel / GetPixel demonstration');
  1052.   StatusLine('Esc aborts or press a key...');
  1053.  
  1054.   GetViewSettings(ViewInfo);
  1055.   with ViewInfo do
  1056.   begin
  1057.     XMax := (x2-x1-1);
  1058.     YMax := (y2-y1-1);
  1059.   end;
  1060.  
  1061.   while not KeyPressed do
  1062.   begin
  1063.     { Plot random pixels }
  1064.     RandSeed := Seed;
  1065.     I := 0;
  1066.     while (not KeyPressed) and (I < NumPts) do
  1067.     begin
  1068.       Inc(I);
  1069.       PutPixel(Random(XMax)+1, Random(YMax)+1, RandColor);
  1070.     end;
  1071.  
  1072.     { Erase pixels }
  1073.     RandSeed := Seed;
  1074.     I := 0;
  1075.     while (not KeyPressed) and (I < NumPts) do
  1076.     begin
  1077.       Inc(I);
  1078.       X := Random(XMax)+1;
  1079.       Y := Random(YMax)+1;
  1080.       Color := GetPixel(X, Y);
  1081.       if Color = RandColor then
  1082.         PutPixel(X, Y, 0);
  1083.     end;
  1084.   end;
  1085.   WaitToGo;
  1086. end; { PutPixelPlay }
  1087.  
  1088. procedure PutImagePlay;
  1089. { Demonstrate the GetImage and PutImage commands }
  1090.  
  1091. const
  1092.   r  = 20;
  1093.   StartX = 100;
  1094.   StartY = 150;
  1095.  
  1096. var
  1097.   CurPort : ViewPortType;
  1098.  
  1099. procedure MoveSaucer(var X, Y : integer; Width, Height : integer);
  1100. var
  1101.   Step : integer;
  1102. begin
  1103.   Step := Random(2*r);
  1104.   if Odd(Step) then
  1105.     Step := -Step;
  1106.   X := X + Step;
  1107.   Step := Random(r);
  1108.   if Odd(Step) then
  1109.     Step := -Step;
  1110.   Y := Y + Step;
  1111.  
  1112.   { Make saucer bounce off viewport walls }
  1113.   with CurPort do
  1114.   begin
  1115.     if (x1 + X + Width - 1 > x2) then
  1116.       X := x2-x1 - Width + 1
  1117.     else
  1118.       if (X < 0) then
  1119.         X := 0;
  1120.     if (y1 + Y + Height - 1 > y2) then
  1121.       Y := y2-y1 - Height + 1
  1122.     else
  1123.       if (Y < 0) then
  1124.         Y := 0;
  1125.   end;
  1126. end; { MoveSaucer }
  1127.  
  1128. var
  1129.   Pausetime : word;
  1130.   Saucer    : pointer;
  1131.   X, Y      : integer;
  1132.   ulx, uly  : word;
  1133.   lrx, lry  : word;
  1134.   Size      : word;
  1135.   I         : word;
  1136. begin
  1137.   ClearDevice;
  1138.   FullPort;
  1139.  
  1140.   { PaintScreen }
  1141.   ClearDevice;
  1142.   MainWindow('GetImage / PutImage Demonstration');
  1143.   StatusLine('Esc aborts or press a key...');
  1144.   GetViewSettings(CurPort);
  1145.  
  1146.   { DrawSaucer }
  1147.   Ellipse(StartX, StartY, 0, 360, r, (r div 3)+2);
  1148.   Ellipse(StartX, StartY-4, 190, 357, r, r div 3);
  1149.   Line(StartX+7, StartY-6, StartX+10, StartY-12);
  1150.   Circle(StartX+10, StartY-12, 2);
  1151.   Line(StartX-7, StartY-6, StartX-10, StartY-12);
  1152.   Circle(StartX-10, StartY-12, 2);
  1153.   SetFillStyle(SolidFill, 1);
  1154.   FloodFill(StartX+1, StartY+4, GetColor);
  1155.  
  1156.   { ReadSaucerImage }
  1157.   ulx := StartX-(r+1);
  1158.   uly := StartY-14;
  1159.   lrx := StartX+(r+1);
  1160.   lry := StartY+(r div 3)+3;
  1161.  
  1162.   Size := ImageSize(ulx, uly, lrx, lry);
  1163.   GetMem(Saucer, Size);
  1164.   GetImage(ulx, uly, lrx, lry, Saucer^);
  1165.   PutImage(ulx, uly, Saucer^, XORput);               { erase image }
  1166.   { Plot some "stars" }
  1167.   for I := 1 to 1000 do
  1168.     PutPixel(Random(MaxX), Random(MaxY), RandColor);
  1169.   X := MaxX div 2;
  1170.   Y := MaxY div 2;
  1171.   PauseTime := 70;
  1172.  
  1173.   { Move the saucer around }
  1174.   repeat
  1175.     X := (X div 8)*8;
  1176.     PutImage(X, Y, Saucer^, XORput);                 { draw image }
  1177.     Delay(PauseTime);
  1178.     PutImage(X, Y, Saucer^, XORput);                 { erase image }
  1179.     MoveSaucer(X, Y, lrx - ulx + 1, lry - uly + 1);  { width/height }
  1180.   until KeyPressed;
  1181.   FreeMem(Saucer, size);
  1182.   WaitToGo;
  1183. end; { PutImagePlay }
  1184.  
  1185. procedure PolyPlay;
  1186. { Draw random polygons with random fill styles on the screen }
  1187. const
  1188.   MaxPts = 5;
  1189. type
  1190.   PolygonType = array[1..MaxPts] of PointType;
  1191. var
  1192.   Poly : PolygonType;
  1193.   I, Color : word;
  1194. begin
  1195.   MainWindow('FillPoly demonstration');
  1196.   StatusLine('Esc aborts or press a key...');
  1197.   repeat
  1198.     Color := RandColor;
  1199.     SetFillStyle(Random(11)+1, Color);
  1200.     SetColor(Color);
  1201.     for I := 1 to MaxPts do
  1202.       with Poly[I] do
  1203.       begin
  1204.         X := Random(MaxX);
  1205.         Y := Random(MaxY);
  1206.       end;
  1207.     FillPoly(MaxPts, Poly);
  1208.   until KeyPressed;
  1209.   WaitToGo;
  1210. end; { PolyPlay }
  1211.  
  1212. procedure FillStylePlay;
  1213. { Display all of the predefined fill styles available }
  1214. var
  1215.   Style    : word;
  1216.   Width    : word;
  1217.   Height   : word;
  1218.   X, Y     : word;
  1219.   I, J     : word;
  1220.   ViewInfo : ViewPortType;
  1221.  
  1222. procedure DrawBox(X, Y : word);
  1223. begin
  1224.   SetFillStyle(Style, White);
  1225.   with ViewInfo do
  1226.     Bar(X, Y, X+Width, Y+Height);
  1227.   Rectangle(X, Y, X+Width, Y+Height);
  1228.   OutTextXY(X+(Width div 2), Y+Height+4, Int2Str(Style));
  1229.   Inc(Style);
  1230. end; { DrawBox }
  1231.  
  1232. begin
  1233.   MainWindow('Pre-defined fill styles');
  1234.   GetViewSettings(ViewInfo);
  1235.   with ViewInfo do
  1236.   begin
  1237.     Width := 2 * ((x2+1) div 13);
  1238.     Height := 2 * ((y2-10) div 10);
  1239.   end;
  1240.   X := Width div 2;
  1241.   Y := Height div 2;
  1242.   Style := 0;
  1243.   for J := 1 to 3 do
  1244.   begin
  1245.     for I := 1 to 4 do
  1246.     begin
  1247.       DrawBox(X, Y);
  1248.       Inc(X, (Width div 2) * 3);
  1249.     end;
  1250.     X := Width div 2;
  1251.     Inc(Y, (Height div 2) * 3);
  1252.   end;
  1253.   SetTextJustify(LeftText, TopText);
  1254.   WaitToGo;
  1255. end; { FillStylePlay }
  1256.  
  1257. procedure FillPatternPlay;
  1258. { Display some user defined fill patterns }
  1259. const
  1260.   Patterns : array[0..11] of FillPatternType = (
  1261.   ($AA, $55, $AA, $55, $AA, $55, $AA, $55),
  1262.   ($33, $33, $CC, $CC, $33, $33, $CC, $CC),
  1263.   ($F0, $F0, $F0, $F0, $F, $F, $F, $F),
  1264.   (0, $10, $28, $44, $28, $10, 0, 0),
  1265.   (0, $70, $20, $27, $25, $27, $4, $4),
  1266.   (0, 0, 0, $18, $18, 0, 0, 0),
  1267.   (0, 0, $3C, $3C, $3C, $3C, 0, 0),
  1268.   (0, $7E, $7E, $7E, $7E, $7E, $7E, 0),
  1269.   (0, 0, $22, $8, 0, $22, $1C, 0),
  1270.   ($FF, $7E, $3C, $18, $18, $3C, $7E, $FF),
  1271.   (0, $10, $10, $7C, $10, $10, 0, 0),
  1272.   (0, $42, $24, $18, $18, $24, $42, 0));
  1273. var
  1274.   Style    : word;
  1275.   Width    : word;
  1276.   Height   : word;
  1277.   X, Y     : word;
  1278.   I, J     : word;
  1279.   ViewInfo : ViewPortType;
  1280.  
  1281. procedure DrawBox(X, Y : word);
  1282. begin
  1283.   SetFillPattern(Patterns[Style], White);
  1284.   with ViewInfo do
  1285.     Bar(X, Y, X+Width, Y+Height);
  1286.   Rectangle(X, Y, X+Width, Y+Height);
  1287.   Inc(Style);
  1288. end; { DrawBox }
  1289.  
  1290. begin
  1291.   MainWindow('User defined fill styles');
  1292.   GetViewSettings(ViewInfo);
  1293.   with ViewInfo do
  1294.   begin
  1295.     Width := 2 * ((x2+1) div 13);
  1296.     Height := 2 * ((y2-10) div 10);
  1297.   end;
  1298.   X := Width div 2;
  1299.   Y := Height div 2;
  1300.   Style := 0;
  1301.   for J := 1 to 3 do
  1302.   begin
  1303.     for I := 1 to 4 do
  1304.     begin
  1305.       DrawBox(X, Y);
  1306.       Inc(X, (Width div 2) * 3);
  1307.     end;
  1308.     X := Width div 2;
  1309.     Inc(Y, (Height div 2) * 3);
  1310.   end;
  1311.   SetTextJustify(LeftText, TopText);
  1312.   WaitToGo;
  1313. end; { FillPatternPlay }
  1314.  
  1315. procedure ColorPlay;
  1316. { Display all of the colors available for the current driver and mode }
  1317. var
  1318.   Color    : word;
  1319.   Width    : word;
  1320.   Height   : word;
  1321.   X, Y     : word;
  1322.   I, J     : word;
  1323.   ViewInfo : ViewPortType;
  1324.  
  1325. procedure DrawBox(X, Y : word);
  1326. begin
  1327.   SetFillStyle(SolidFill, Color);
  1328.   SetColor(Color);
  1329.   with ViewInfo do
  1330.     Bar(X, Y, X+Width, Y+Height);
  1331.   Rectangle(X, Y, X+Width, Y+Height);
  1332.   Color := GetColor;
  1333.   if Color = 0 then
  1334.   begin
  1335.     SetColor(White);
  1336.     Rectangle(X, Y, X+Width, Y+Height);
  1337.   end;
  1338.   Color := Succ(Color);
  1339. end; { DrawBox }
  1340.  
  1341. begin
  1342.   MainWindow('256 Color demonstration');
  1343.   Color := 0;
  1344.   GetViewSettings(ViewInfo);
  1345.   with ViewInfo do
  1346.   begin
  1347.     Width := 2 * ((x2-x1+1) div 46);
  1348.     Height := 2 * ((y2-x1+1) div 47);
  1349.   end;
  1350.   X := Width div 3;
  1351.   Y := Height div 3;
  1352.   for J := 1 to 16 do
  1353.   begin
  1354.     for I := 1 to 16 do
  1355.     begin
  1356.       DrawBox(X, Y);
  1357.       Inc(X, (Width div 2) * 3);
  1358.     end;
  1359.     X := Width div 3;
  1360.     Inc(Y, (Height div 2) * 3);
  1361.   end;
  1362.   WaitToGo;
  1363. end; { ColorPlay }
  1364.  
  1365. procedure PalettePlay;
  1366. { Demonstrate the use of the SetRGBPalette command }
  1367. const
  1368.   XBars = 15;
  1369.   YBars = 10;
  1370. type
  1371.   RGBColor   = record
  1372.                  R, G, B : byte;
  1373.                end;
  1374.   VGAPalette = array[0..255] of RGBColor;
  1375.  
  1376. var
  1377.   I, J     : word;
  1378.   X, Y     : word;
  1379.   Color    : word;
  1380.   ViewInfo : ViewPortType;
  1381.   Width    : word;
  1382.   Height   : word;
  1383.   VGAPal   : VGAPalette;
  1384.   Rand     : integer;
  1385.  
  1386. procedure ReadDACBlock(Start, Count : integer; var Pal : VGAPalette);
  1387. var
  1388.   Regs : Registers;
  1389. begin
  1390.   with Regs do
  1391.   begin
  1392.     AH := $10;
  1393.     AL := $17;
  1394.     BX := Start;
  1395.     CX := Count;
  1396.     ES := Seg(Pal);
  1397.     DX := Ofs(Pal);
  1398.   end;
  1399.   Intr($10, Regs);
  1400. end;
  1401.  
  1402. procedure SetDACBlock(Start, Count : integer; var Pal : VGAPalette);
  1403. var
  1404.   Regs : Registers;
  1405. begin
  1406.   with Regs do
  1407.   begin
  1408.     AH := $10;
  1409.     AL := $12;
  1410.     BX := Start;
  1411.     CX := Count;
  1412.     ES := Seg(Pal);
  1413.     DX := Ofs(Pal);
  1414.   end;
  1415.   Intr($10, Regs);
  1416. end;
  1417.  
  1418. begin
  1419.   ReadDACBlock(0, 256, VGAPal);
  1420.   MainWindow('SetRGBPalette demonstration');
  1421.   StatusLine('Press any key...');
  1422.   GetViewSettings(ViewInfo);
  1423.   with ViewInfo do
  1424.   begin
  1425.     Width := (x2-x1) div XBars;
  1426.     Height := (y2-y1) div YBars;
  1427.   end;
  1428.   X := 0; Y := 0;
  1429.   Color := 0;
  1430.   for J := 1 to YBars do
  1431.   begin
  1432.     for I := 1 to XBars do
  1433.     begin
  1434.       SetFillStyle(SolidFill, Color);
  1435.       Bar(X, Y, X+Width, Y+Height);
  1436.       Inc(X, Width+1);
  1437.       Inc(Color);
  1438.       Color := Color mod 16;
  1439.     end;
  1440.     X := 0;
  1441.     Inc(Y, Height+1);
  1442.   end;
  1443.   repeat
  1444.     {SetPalette(Random(16), VGAPal[Random(256)]);}
  1445.     with VGAPal[Random(16)] do
  1446.       SetRGBPalette(Random(16), R, G, B);
  1447.   until KeyPressed;
  1448.   SetDACBlock(0, 256, VGAPal);
  1449.   WaitToGo;
  1450. end; { PalettePlay }
  1451.  
  1452. procedure CrtModePlay;
  1453. { Demonstrate the use of RestoreCrtMode and SetGraphMode }
  1454. var
  1455.   ViewInfo : ViewPortType;
  1456.   Ch       : char;
  1457. begin
  1458.   MainWindow('SetGraphMode / RestoreCrtMode demo');
  1459.   GetViewSettings(ViewInfo);
  1460.   SetTextJustify(CenterText, CenterText);
  1461.   with ViewInfo do
  1462.   begin
  1463.     OutTextXY((x2-x1) div 2, (y2-y1) div 2, 'Now you are in graphics mode');
  1464.     StatusLine('Press any key for text mode...');
  1465.     repeat until KeyPressed;
  1466.     Ch := ReadKey;
  1467.     RestoreCrtmode;
  1468.     Writeln('Now you are in text mode.');
  1469.     Write('Press any key to go back to graphics...');
  1470.     repeat until KeyPressed;
  1471.     Ch := ReadKey;
  1472.     SetGraphMode(GetGraphMode);
  1473.     MainWindow('SetGraphMode / RestoreCrtMode demo');
  1474.     SetTextJustify(CenterText, CenterText);
  1475.     OutTextXY((x2-x1) div 2, (y2-y1) div 2, 'Back in graphics mode...');
  1476.   end;
  1477.   WaitToGo;
  1478. end; { CrtModePlay }
  1479.  
  1480. procedure LineStylePlay;
  1481. { Demonstrate the predefined line styles available }
  1482. var
  1483.   Style    : word;
  1484.   Step     : word;
  1485.   X, Y     : word;
  1486.   ViewInfo : ViewPortType;
  1487.  
  1488. begin
  1489.   ClearDevice;
  1490.   DefaultColors;
  1491.   MainWindow('Pre-defined line styles');
  1492.   GetViewSettings(ViewInfo);
  1493.   with ViewInfo do
  1494.   begin
  1495.     X := 35;
  1496.     Y := 10;
  1497.     Step := (x2-x1) div 11;
  1498.     SetTextJustify(LeftText, TopText);
  1499.     OutTextXY(X, Y, 'NormWidth');
  1500.     SetTextJustify(CenterText, TopText);
  1501.     for Style := 0 to 3 do
  1502.     begin
  1503.       SetLineStyle(Style, 0, NormWidth);
  1504.       Line(X, Y+20, X, Y2-40);
  1505.       OutTextXY(X, Y2-30, Int2Str(Style));
  1506.       Inc(X, Step);
  1507.     end;
  1508.     Inc(X, 2*Step);
  1509.     SetTextJustify(LeftText, TopText);
  1510.     OutTextXY(X, Y, 'ThickWidth');
  1511.     SetTextJustify(CenterText, TopText);
  1512.     for Style := 0 to 3 do
  1513.     begin
  1514.       SetLineStyle(Style, 0, ThickWidth);
  1515.       Line(X, Y+20, X, Y2-40);
  1516.       OutTextXY(X, Y2-30, Int2Str(Style));
  1517.       Inc(X, Step);
  1518.     end;
  1519.   end;
  1520.   SetTextJustify(LeftText, TopText);
  1521.   WaitToGo;
  1522. end; { LineStylePlay }
  1523.  
  1524. procedure UserLineStylePlay;
  1525. { Demonstrate user defined line styles }
  1526. var
  1527.   Style    : word;
  1528.   X, Y, I  : word;
  1529.   ViewInfo : ViewPortType;
  1530. begin
  1531.   MainWindow('User defined line styles');
  1532.   GetViewSettings(ViewInfo);
  1533.   with ViewInfo do
  1534.   begin
  1535.     X := 4;
  1536.     Y := 10;
  1537.     Style := 0;
  1538.     I := 0;
  1539.     while X < X2-4 do
  1540.     begin
  1541.       {$B+}
  1542.       Style := Style or (1 shl (I mod 16));
  1543.       {$B-}
  1544.       SetLineStyle(UserBitLn, Style, NormWidth);
  1545.       Line(X, Y, X, (y2-y1)-Y);
  1546.       Inc(X, 5);
  1547.       Inc(I);
  1548.       if Style = 65535 then
  1549.       begin
  1550.         I := 0;
  1551.         Style := 0;
  1552.       end;
  1553.     end;
  1554.   end;
  1555.   WaitToGo;
  1556. end; { UserLineStylePlay }
  1557.  
  1558.  
  1559. procedure SayGoodbye;
  1560. { Say goodbye and then exit the program }
  1561. var
  1562.   ViewInfo : ViewPortType;
  1563. begin
  1564.   MainWindow('');
  1565.   GetViewSettings(ViewInfo);
  1566.   SetTextStyle(TriplexFont, HorizDir, 4);
  1567.   SetTextJustify(CenterText, CenterText);
  1568.   with ViewInfo do
  1569.     OutTextXY((x2-x1) div 2, (y2-y1) div 2, 'That''s all folks!');
  1570.   StatusLine('Press any key to quit...');
  1571.   repeat until KeyPressed;
  1572. end; { SayGoodbye }
  1573.  
  1574. begin { program body }
  1575.   ClrScr;
  1576.   writeln('VGA BGI Demo Program  Copyright(c) 1987,1989 Borland International, Inc.');
  1577.   writeln;
  1578.   Initialize;
  1579.   ReportStatus;
  1580.   AspectRatioPlay;
  1581.   FillEllipsePlay;
  1582.   SectorPlay;
  1583.   WriteModePlay;
  1584.   ColorPlay;
  1585.   PalettePlay;
  1586.   PutPixelPlay;
  1587.   PutImagePlay;
  1588.   RandBarPlay;
  1589.   SolidBarPlay;
  1590.   BarPlay;
  1591.   Bar3DPlay;
  1592.   ArcPlay;
  1593.   CirclePlay;
  1594.   PiePlay;
  1595.   LineToPlay;
  1596.   LineRelPlay;
  1597.   LineStylePlay;
  1598.   UserLineStylePlay;
  1599.   TextDump;
  1600.   TextPlay;
  1601.   CrtModePlay;
  1602.   FillStylePlay;
  1603.   FillPatternPlay;
  1604.   PolyPlay;
  1605.   SayGoodbye;
  1606.   CloseGraph;
  1607. end.
  1608.